perm filename TIC3D.LSP[206,JMC] blob
sn#076835 filedate 1973-12-12 generic text, type T, neo UTF8
(DEFPROP TICTACFNS
(TRY2 MAKEL
COMMENCE
SQ
EXT
NEWGAME
TER
IMVAL
SUCCESSORS
REVERT
UPDATE
PTS
LINES
SORT
SORTA
SORTB
SORTC
WIN
ANSWER
DOUBLETH
TWOLIS
THREAT)
VALUE)
(DEFPROP MAKEL
(LAMBDA(M N)
(COND ((GREATERP M N) NIL) (T (CONS M (MAKEL (ADD1 M) N)))))
EXPR)
(DEFPROP COMMENCE
(LAMBDA NIL
(PROG (N X Y I)
(ARRAY POINTS T 114)
(ARRAY LINES T 100)
(ARRAY XCOUNT 44 114)
(ARRAY OCOUNT 44 114)
(ARRAY XLIVE T 5)
(ARRAY OLIVE T 5)
(SETQ N 0)
(SETQ X 0)
LX1 (COND ((GREATERP X 3) (GO DX1)))
(SETQ Y 0)
LY1 (COND ((GREATERP Y 3) (GO DY1)))
(STORE (POINTS N)
(LIST (SQ X Y 0) (SQ X Y 1) (SQ X Y 2) (SQ X Y 3)))
(STORE (POINTS (PLUS N 20))
(LIST (SQ X 0 Y) (SQ X 1 Y) (SQ X 2 Y) (SQ X 3 Y)))
(STORE (POINTS (PLUS N 40))
(LIST (SQ 0 X Y) (SQ 1 X Y) (SQ 2 X Y) (SQ 3 X Y)))
(SETQ N (ADD1 N))
(SETQ Y (ADD1 Y))
(GO LY1)
DY1 (SETQ X (ADD1 X))
(GO LX1)
DX1 (SETQ N 60)
(SETQ X 0)
LX2 (COND ((GREATERP X 3) (GO DX2)))
(STORE (POINTS N)
(LIST (SQ X 0 0) (SQ X 1 1) (SQ X 2 2) (SQ X 3 3)))
(STORE (POINTS (ADD1 N))
(LIST (SQ X 0 3) (SQ X 1 2) (SQ X 2 1) (SQ X 3 0)))
(STORE (POINTS (PLUS N 10))
(LIST (SQ 0 X 0) (SQ 1 X 1) (SQ 2 X 2) (SQ 3 X 3)))
(STORE (POINTS (PLUS N 11))
(LIST (SQ 0 X 3) (SQ 1 X 2) (SQ 2 X 1) (SQ 3 X 0)))
(STORE (POINTS (PLUS N 20))
(LIST (SQ 0 0 X) (SQ 1 1 X) (SQ 2 2 X) (SQ 3 3 X)))
(STORE (POINTS (PLUS N 21))
(LIST (SQ 0 3 X) (SQ 1 2 X) (SQ 2 1 X) (SQ 3 0 X)))
(SETQ N (PLUS N 2))
(SETQ X (ADD1 X))
(GO LX2)
DX2 (STORE (POINTS 110)
(LIST (SQ 0 0 0) (SQ 1 1 1) (SQ 2 2 2) (SQ 3 3 3)))
(STORE (POINTS 111)
(LIST (SQ 0 0 3) (SQ 1 1 2) (SQ 2 2 1) (SQ 3 3 0)))
(STORE (POINTS 112)
(LIST (SQ 0 3 0) (SQ 1 2 1) (SQ 2 1 2) (SQ 3 0 3)))
(STORE (POINTS 113)
(LIST (SQ 0 3 3) (SQ 1 2 2) (SQ 2 1 1) (SQ 3 0 0)))
(SETQ I 0)
LI1 (COND ((GREATERP I 77) (GO DI1)))
(STORE (LINES I) NIL)
(SETQ I (ADD1 I))
(GO LI1)
DI1 (SETQ N 0)
LN1 (COND ((GREATERP N 113) (GO DN1)))
(SETQ X (POINTS N))
LX3 (COND ((NULL X) (GO DX3)))
(STORE (LINES (CAR X)) (CONS N (LINES (CAR X))))
(SETQ X (CDR X))
(GO LX3)
DX3 (SETQ N (ADD1 N))
(GO LN1)
DN1))
EXPR)
(DEFPROP SQ
(LAMBDA (X Y Z) (PLUS X (TIMES 4 Y) (TIMES 20 Z)))
EXPR)
(DEFPROP EXT
(LAMBDA (P) (CAR P))
EXPR)
(DEFPROP NEWGAME
(LAMBDA NIL
(PROG (N)
(SETQ N -1)
L (SETQ N (ADD1 N))
(STORE (XCOUNT N) 0)
(STORE (OCOUNT N) 0)
(COND ((LESSP N 113) (GO L)))
(SETQ P1 NIL)
(SETQ XS NIL)
(SETQ OS NIL)
(SETQ BS (MAKEL 0 77))
(SETQ W NIL)
(SETQ LEVEL 0)
(SETQ SLEVEL 0)
(SETQ COUNT 0)
(SETQ N 1)
L1 (COND ((EQUAL N 5) (GO D1)))
(STORE (XLIVE N) NIL)
(STORE (OLIVE N) NIL)
(SETQ N (ADD1 N))
(GO L1)
D1 (RETURN (QUOTE (NEW GAME)))))
EXPR)
(DEFPROP TER
(LAMBDA(P ALPHA BETA)
(AND (NOT (NULL P))
(OR (EQUAL LEVEL 100)
(LESSP (DIFFERENCE 100 LEVEL) ALPHA)
(GREATERP (PLUS -100 LEVEL) BETA)
(COND (W
(ORLIS (FUNCTION (LAMBDA (L) (EQUAL (XCOUNT L) 4)))
(LINES (CAR P))))
(T
(ORLIS (FUNCTION (LAMBDA (L) (EQUAL (OCOUNT L) 4)))
(LINES (CAR P))))))))
EXPR)
(DEFPROP IMVAL
(LAMBDA(P)
(COND (W
(PROG (N)
(SETQ N 0)
L3 (SETQ N (ADD1 N))
(COND
((EQUAL 3 (XCOUNT N))
(RETURN (DIFFERENCE 12 LEVEL))))
(COND ((LESSP N 10) (GO L3)) (T (RETURN 0)))))
(T
(PROG (N)
(SETQ N 0)
L4 (SETQ N (ADD1 N))
(COND
((EQUAL 3 (OCOUNT N)) (RETURN (PLUS -12 LEVEL))))
(COND ((LESSP N 10) (GO L4)) (T (RETURN 0)))))))
EXPR)
(DEFPROP SUCCESSORS
(LAMBDA (P) (SORT (MAPCAR (FUNCTION (LAMBDA (X) (CONS X P))) BS)))
EXPR)
(DEFPROP REVERT
(LAMBDA NIL
(PROG (A U X)
(SETQ LEVEL (SUB1 LEVEL))
(SETQ SLEVEL (SUB1 SLEVEL))
(SETQ BS (CONS (CAR (COND (W XS) (T OS))) BS))
(COND (W (SETQ XS (CDR XS))) (T (SETQ OS (CDR OS))))
(SETQ U (LINES (CAR P1)))
(COND (W (GO L1)))
L2 (COND ((NULL U) (GO A1)))
(SETQ X (CAR U))
(COND
((EQUAL (XCOUNT X) 0)
(PROG NIL
(STORE (OLIVE (OCOUNT X))
(DELETE X (OLIVE (OCOUNT X))))
(COND
((GREATERP (OCOUNT X) 1)
(STORE (OLIVE (SUB1 (OCOUNT X)))
(CONS X (OLIVE (SUB1 (OCOUNT X)))))))))
(T
(COND
((EQUAL (OCOUNT X) 1)
(STORE (XLIVE (XCOUNT X))
(CONS X (XLIVE (XCOUNT X))))))))
(STORE (OCOUNT (CAR U)) (SUB1 (OCOUNT (CAR U))))
(SETQ U (CDR U))
(GO L2)
L1 (COND ((NULL U) (GO A1)))
(SETQ X (CAR U))
(COND
((EQUAL (OCOUNT X) 0)
(PROG NIL
(STORE (XLIVE (XCOUNT X))
(DELETE X (XLIVE (XCOUNT X))))
(COND
((GREATERP (XCOUNT X) 1)
(STORE (XLIVE (SUB1 (XCOUNT X)))
(CONS X (XLIVE (SUB1 (XCOUNT X)))))))))
(T
(COND
((EQUAL (XCOUNT X) 1)
(STORE (OLIVE (OCOUNT X))
(CONS X (OLIVE (OCOUNT X))))))))
(STORE (XCOUNT (CAR U)) (SUB1 (XCOUNT (CAR U))))
(SETQ U (CDR U))
(GO L1)
A1
L6 (SETQ W (NOT W))
(SETQ P1 (CDR P1))
(RETURN)))
EXPR)
(DEFPROP UPDATE
(LAMBDA(M)
(PROG (A U X)
(SETQ LEVEL (ADD1 LEVEL))
(SETQ SLEVEL (ADD1 SLEVEL))
(SETQ U (LINES M))
(COND (W (GO L9)))
L10 (COND ((NULL U) (GO A9)))
(SETQ X (CAR U))
(STORE (XCOUNT X) (ADD1 (XCOUNT X)))
(COND
((EQUAL (OCOUNT X) 0)
(PROG NIL
(STORE (XLIVE (XCOUNT X))
(CONS X (XLIVE (XCOUNT X))))
(COND
((GREATERP (XCOUNT X) 1)
(STORE (XLIVE (SUB1 (XCOUNT X)))
(DELETE X (XLIVE (SUB1 (XCOUNT X)))))))))
(T
(COND
((EQUAL (XCOUNT X) 1)
(STORE (OLIVE (OCOUNT X))
(DELETE X (OLIVE (OCOUNT X))))))))
(SETQ U (CDR U))
(GO L10)
L9 (COND ((NULL U) (GO A9)))
(SETQ X (CAR U))
(STORE (OCOUNT X) (ADD1 (OCOUNT X)))
(COND
((EQUAL (XCOUNT X) 0)
(PROG NIL
(STORE (OLIVE (OCOUNT X))
(CONS X (OLIVE (OCOUNT X))))
(COND
((GREATERP (OCOUNT X) 1)
(STORE (OLIVE (SUB1 (OCOUNT X)))
(DELETE X (OLIVE (SUB1 (OCOUNT X)))))))))
(T
(COND
((EQUAL (OCOUNT X) 1)
(STORE (XLIVE (XCOUNT X))
(DELETE X (XLIVE (XCOUNT X))))))))
(SETQ U (CDR U))
(GO L9)
A9 (COND (W (SETQ OS (CONS M OS))) (T (SETQ XS (CONS M XS))))
(SETQ BS (DELETE M BS))
(SETQ P1 (CONS M P1))
(SETQ COUNT (ADD1 COUNT))
L8 (SETQ W (NOT W))
(RETURN)))
EXPR)
(DEFPROP SORT
(LAMBDA (U) (SORTA U NIL NIL))
EXPR)
(DEFPROP SORTA
(LAMBDA(U TH ORD)
(COND ((NULL U) (APPEND TH ORD))
((WIN (CAR U)) (LIST (CAR U)))
((ANSWER (CAR U)) (SORTB (CDR U) (CAR U)))
((DOUBLETH (CAR U)) (SORTC (CDR U) (CAR U)))
((THREAT (CAR U)) (SORTA (CDR U) (CONS (CAR U) TH) ORD))
(T (SORTA (CDR U) TH (CONS (CAR U) ORD)))))
EXPR)
(DEFPROP SORTB
(LAMBDA(U M)
(COND ((NULL U) (LIST M))
((WIN (CAR U)) (LIST (CAR U)))
(T (SORTB (CDR U) M))))
EXPR)
(DEFPROP SORTC
(LAMBDA(U M)
(COND ((NULL U) (LIST M))
((WIN (CAR U)) (LIST (CAR U)))
((ANSWER (CAR U)) (SORTB (CDR U) (CAR U)))
(T (SORTC (CDR U) M))))
EXPR)
(DEFPROP WIN
(LAMBDA(P)
(COND (W
(ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (OCOUNT X))))
(LINES (CAR P))))
(T
(ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (XCOUNT X))))
(LINES (CAR P))))))
EXPR)
(DEFPROP ANSWER
(LAMBDA(P)
(COND (W
(ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (XCOUNT X))))
(LINES (CAR P))))
(T
(ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (OCOUNT X))))
(LINES (CAR P))))))
EXPR)
(DEFPROP DOUBLETH
(LAMBDA(P)
(TWOLIS
(FUNCTION
(LAMBDA(X)
(AND (EQUAL 1 (COND (W (OCOUNT X)) (T (XCOUNT X))))
(ORLIS (FUNCTION (LAMBDA (W) (MEMBER X (LINES W))))
(DELETE (CAR P) BS)))))
(LINES (CAR P))))
EXPR)
(DEFPROP TWOLIS
(LAMBDA(PRED U)
(AND (NOT (NULL U))
(OR (AND (PRED (CAR U)) (ORLIS PRED (CDR U)))
(TWOLIS PRED (CDR U)))))
EXPR)
(DEFPROP THREAT
(LAMBDA(P)
(ORLIS
(FUNCTION
(LAMBDA(X)
(AND (EQUAL 1 (COND (W (OCOUNT X)) (T (XCOUNT X))))
(ORLIS (FUNCTION (LAMBDA (W) (MEMBER X (LINES W))))
(DELETE (CAR P) BS)))))
(LINES (CAR P))))
EXPR)
ROP DOUBLETH
(LAMBDA(P)
(TWOLIS
(FUNCTION
(LAMBDA(X)
(AND (EQUAL 1 (COND (W (OCOUNT X)) (T (XCOUNT X))))